home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / 4cmp22s.zip / MULTID.4TH < prev    next >
Text File  |  1994-10-30  |  17KB  |  642 lines
  1. \ ForthCMP  Multitasking Module
  2. \ Copyright 1985, 1993 (C) By Thomas Almy.  All rights reserved.
  3.  
  4. \ Permission is granted to registered users of ForthCMP to sell or distribute
  5. \ computer programs incorporating the compiled contents of this file.
  6.  
  7. \ This module writes direct to the display for terminal I/O
  8.  
  9.  
  10. .( LOADING MULTID) CR
  11. FIND EMIT? [IF] DROP 1 [ELSE] 0 [THEN] CONSTANT facl  \ FACILITY Wordset used
  12. INCLUDE INTS
  13. INCLUDE FARMEM1
  14. 10 HEX
  15.  
  16. \ If EGA is defined non-zero then 43 line EGA code is generated
  17. FIND EGA [IF] DROP [ELSE] 0 CONSTANT EGA [THEN]
  18.  
  19. \ If VGA is defined non-zero then 50 line VGA code is generated
  20. FIND VGA [IF] DROP [ELSE] 0 CONSTANT VGA [THEN]
  21.  
  22. EGA 0<> VGA 0<> OR CONSTANT ENHANCED
  23.  
  24. ENHANCED [IF] 0 CONSTANT VID-DELAY [THEN]  \ no vid delay if EGA or VGA
  25. ENHANCED 0=  [IF] VARIABLE crtport  3D4 crtport ! [THEN]
  26.  
  27. \ If VID-DELAY is defined non-zero then anti-snow code is added
  28. FIND VID-DELAY [IF] DROP [ELSE] 0 CONSTANT VID-DELAY [THEN]
  29.  
  30. VARIABLE vidseg     \ VIDEO SEGMENT
  31. B800 vidseg !
  32. 50 CONSTANT c/l     \ Characters per line
  33. EGA [IF] 2B [ELSE] VGA [IF] 32 [ELSE] 19 [THEN] [THEN]
  34.    CONSTANT l/s     \ lines per screen
  35.  
  36.  
  37. DECIMAL  
  38. 0 0 IN/OUT NEED SINGLE 
  39. 0 0 IN/OUT NEED MULTI
  40. 0 0 IN/OUT NEED PAUSE
  41. 0 0 IN/OUT NEED end-timer
  42. 0 0 IN/OUT NEED start-timer
  43. 0 0 IN/OUT NEED PAGE
  44.  
  45.  
  46. VARIABLE ?multi         \ true if multitasking turned on
  47. VARIABLE user           \ disp into user segment--used at comp time
  48. VARIABLE CTASK          \ pointer to task list
  49. VARIABLE inaccept       \ executing EXPECT -- only one at a time, please!
  50.  
  51.  \ Semaphores
  52.  
  53. 1 0 IN/OUT
  54. : SEMA BEGIN DUP @ WHILE PAUSE REPEAT ON ;
  55.  
  56. 1 0 IN/OUT
  57. : PHORE  OFF PAUSE ;
  58.  
  59.  
  60. 0 0 IN/OUT 
  61. : BYE  unsetup-vid end-timer bye ;
  62.  
  63.  \ Memory management interface
  64. 1 1 IN/OUT
  65. : GET malloc IF    ." OUT OF MEMORY " BYE THEN ;
  66.  
  67.  \ USER VARIABLES 
  68. H: UALLOT  DSEG user @  +  user ! ;
  69. 1 2 IN/OUT
  70. H: UCREATE user @ CONSTANT ;
  71. H: UVARIABLE  UCREATE 2 UALLOT ;
  72. H: URESET DSEG  0 user ! ;
  73. URESET
  74.  \ redefinition of primitive I/O functions
  75. HEX
  76. 1 0 IN/OUT
  77. : storecursor ( DISPL -- )  CTASK @ 12 + CS: ! ;
  78.  
  79. 1 0 IN/OUT
  80. : setcursor (  DISPL -- )  
  81. ENHANCED [IF]
  82.     2/ DUP 0F 3D4 PC! 3D5 PC! >< 0E 3D4 PC! 3D5 PC! 
  83. [ELSE]
  84.     2/ DUP 0F crtport @ PC! crtport @ 1+ PC!
  85.     >< 0E crtport @ PC! crtport @ 1+ PC! 
  86. [THEN]
  87. ;
  88.  
  89. 0 0 IN/OUT
  90. : nocursor  l/s c/l * 2* 1- setcursor ( OFF SCREEN ! ) ;
  91.  
  92. 2 0 IN/OUT
  93. : AT-XY  c/l * + 2*  storecursor ;
  94.  
  95.  
  96. ENHANCED [IF]
  97. 0 0 IN/OUT
  98. EGA [IF]
  99. CODE set-ega
  100.     03 # AX MOV  10 INT                     \ SET MODE 3
  101.     1112 # AX MOV  0 # BL MOV  10 INT       \ Load 8X8 font
  102.     1200 # AX MOV  20 # BL MOV  10 INT      \ Load new printscreen
  103.     1 # AH MOV  707 # CX MOV  10 INT        \ LOAD CURSOR SCAN LINES
  104.     3D4 # DX MOV  0A # AL MOV  [DX] BYTE OUT \ set cursor 
  105.     FWD, THEN,
  106.     DX INC
  107.     6 # AL MOV  [DX] OUT
  108.     RET
  109. END-CODE
  110. [ELSE]  \ must be VGA
  111. CODE set-ega
  112.     1202 # AX MOV 30 # BL MOV 10 INT  \ 400 scan lines
  113.     03 # AX MOV  10 INT                     \ SET MODE 3
  114.     1112 # AX MOV  0 # BL MOV  10 INT       \ Load 8X8 font
  115.     1200 # AX MOV  20 # BL MOV  10 INT      \ Load new printscreen
  116.     RET
  117. END-CODE
  118. [THEN]
  119.  
  120. 0 0 IN/OUT
  121. CODE unset-ega
  122. VGA [IF]
  123.     1201 # AX MOV 30 # BL MOV 10 INT  \ 350 scan lines
  124. [THEN]
  125.     03 # AX MOV  10 INT  RET  END-CODE
  126. [THEN] 
  127.  
  128. 0 0 IN/OUT
  129. : setup-vid
  130. ENHANCED [IF]
  131.     set-ega
  132.     CTASK @ 12 + CS: OFF    \ home cursor
  133. [ELSE]
  134.     40 49 C@L 7 = IF 3B4 crtport ! B000 vidseg ! THEN \ MONOCHROME
  135.     40 50 C@L 40 51 C@L AT-XY
  136.     vidseg @  c/l l/s 1- * 2* 1+ C@L  CTASK @ 14 + CS: ! 
  137. [THEN]
  138. ;
  139.  
  140.  CODE unsetup-vid  
  141. ENHANCED [IF]
  142.     CALL' PAGE
  143.     CALL' unset-ega
  144.     DX DX XOR
  145. [ELSE]
  146.     CTASK [] BX MOV
  147.     CS: 12 +[BX] AX MOV  \ cursor offset
  148.     c/l # BX MOV 
  149.     DX DX XOR
  150.     AX 1 SAR  
  151.     BX IDIV
  152.     AL DH MOV  
  153. [THEN]
  154.     2 # AH MOV 
  155.     BH BH XOR  
  156.     10 INT  
  157.     RET 
  158. END-CODE \ unsetup-vid
  159.  
  160. CODE scrmove  ( source dest wordCount -- )
  161.     BX POP 
  162.     CX POP
  163.     DI POP
  164.     SI POP
  165.     LOOP IF,
  166.         DS PUSHSEG
  167. VID-DELAY [IF]  
  168.         B800 # vidseg [] CMP  =0 IF,
  169.             3DA # DX MOV
  170.             BEGIN,  
  171.                 BYTE [DX] IN  
  172.                 8 # AL TEST  
  173.             =0 ~ UNTIL,
  174.             DX DEC
  175.             DX DEC
  176.             21 # AL MOV
  177.             BYTE [DX] OUT
  178.         THEN, 
  179. [THEN]
  180.         vidseg [] AX MOV
  181.         AX DS >SEG
  182.         AX ES >SEG
  183.         REPZ MOVS
  184.         DS POPSEG
  185. VID-DELAY [IF]
  186.         B800 # vidseg [] CMP  =0 IF,
  187.             3D8 # DX MOV
  188.             29 # AL MOV
  189.             BYTE [DX] OUT
  190.         THEN, 
  191. [THEN]
  192.     THEN, 
  193.     BX JMPI 
  194. END-CODE \ scrmove
  195.  
  196. 2 0 IN/OUT
  197. CODE scrfill ( source wordCount -- )
  198.     vidseg [] ES >SEG
  199.     20 # BYTE ES: [BX] MOV
  200.     CTASK [] DI MOV
  201.     CS: 14 +[DI] CL MOV  \ style
  202.     CL ES: 1 +[BX] MOV
  203.     BX PUSH
  204.     BX INC 
  205.     BX INC 
  206.     BX PUSH  
  207.     AX DEC 
  208.     AX PUSH
  209.     CALL' scrmove
  210.     RET
  211. END-CODE \ scrfill
  212.  
  213. 0 0 IN/OUT
  214. : scrollup  c/l 2*  0  c/l l/s 1- * scrmove
  215.     c/l l/s 1- * 2*  c/l    scrfill
  216.     c/l l/s 1- * 2*  CTASK @ 12 + CS: ! ( set cursor ) ;
  217.  
  218. 0 2 IN/OUT
  219. : ?XY     CTASK @ 12 + CS: @  2/  0 c/l UM/MOD ;
  220.  
  221. 1 0 IN/OUT
  222. : FOREGROUND 0F AND CTASK @ 14 + TUCK CS: @ F0 AND OR SWAP CS: ! ;
  223.  
  224. 1 0 IN/OUT
  225. : BACKGROUND 7 AND 4 LSHIFT CTASK @ 14 + TUCK CS: @ 0F AND OR SWAP CS: ! ;
  226.  
  227.  
  228. : EMIT  
  229.     CTASK @ 12 + CS: @  c/l l/s * 2* >= IF scrollup THEN
  230.     vidseg @ CTASK @ 12 + CS: @ C!L
  231.     CTASK @ 14 + CS: @ vidseg @ CTASK @ 12 + CS: @ 1+ C!L
  232.     CTASK @ 12 + CS: @ CELL+ storecursor  PAUSE ;
  233.  
  234. : CR
  235.     CTASK @ 12 + CS: @  
  236.     c/l 2*  U/  1+  c/l 2*  *
  237.     DUP c/l l/s * 2* = IF DROP scrollup  CTASK @ 12 + CS: @ THEN
  238.     storecursor  PAUSE ;
  239.  
  240. : SPACES
  241.     DUP 0> IF
  242.         c/l l/s * 2*  CTASK @ 12 + CS: @ - OVER 2* < IF ( too big )
  243.         0 DO BL EMIT LOOP ELSE
  244.             CTASK @ 12 + CS: @  SWAP 2DUP scrfill
  245.         2* + storecursor  PAUSE 
  246.         THEN 
  247.     ELSE   DROP
  248.     THEN
  249. ;
  250.  
  251.  
  252. 2 1 IN/OUT
  253. CODE (type) ( AX has count, BX has string, result is cursor position )
  254.     BX SI MOV
  255.     CTASK [] BX MOV
  256.     CS: 12 +[BX] DI MOV \ cursor
  257.     AX CX MOV
  258.     CS: 14 +[BX] AH MOV \ style
  259.     vidseg [] ES >SEG
  260.     LOOP IF, 
  261.         BEGIN,
  262.             BYTE LODS
  263.             STOS  
  264.         LOOP ~ UNTIL,
  265.     THEN,
  266.     DI AX MOV       \ final cursor position
  267.     RET
  268. END-CODE \ (type)
  269.  
  270. : TYPE 
  271.     c/l l/s * 2*  CTASK @ 12 + CS: @ - OVER 2* < IF ( too big )
  272.         0 ?DO COUNT EMIT LOOP DROP
  273.     ELSE 
  274.         (type) storecursor PAUSE 
  275.     THEN ;
  276.  
  277. 2 1 IN/OUT
  278. CODE (cs:type) ( AX has count, BX has string, result is cursor position)
  279.     BX SI MOV
  280.     CTASK [] BX MOV
  281.     CS: 12 +[BX] DI MOV \ cursor
  282.     AX CX MOV
  283.     CS: 14 +[BX] AH MOV \ style
  284.     vidseg [] ES >SEG
  285.     LOOP IF, 
  286.         BEGIN,
  287.             CS: BYTE LODS
  288.             STOS  
  289.         LOOP ~ UNTIL,
  290.     THEN,
  291.     DI AX MOV       \ final cursor position
  292.     RET
  293. END-CODE \ (cs:type)
  294.  
  295. : CS:TYPE 
  296.     c/l l/s * 2* CTASK @ 12 + CS: @ - OVER 2* < IF ( too big )
  297.         0 ?DO CS: COUNT EMIT LOOP DROP
  298.     ELSE 
  299.         (cs:type) storecursor PAUSE 
  300.     THEN ;
  301.  
  302.  
  303. 0 0 IN/OUT 
  304. : PAGE  0  c/l l/s *  scrfill  0 storecursor ;
  305.  
  306. 0 1 IN/OUT
  307. facl [IF]
  308. CODE EKEY?
  309. [ELSE]
  310. CODE KEY?
  311. [THEN]
  312.     CALL' PAUSE     \ allow another task to execute
  313.     1 # AH MOV 
  314.     16 INT 
  315.     0 # AX MOV
  316.     =0 ~ IF, AX DEC  THEN,
  317.     RET
  318. END-CODE \ KEY?
  319.  
  320. : PAD CTASK @ 18 + CS: @ ;
  321.  
  322.  
  323. facl [IF]
  324. VARIABLE pchr -1 pchr !
  325. : KEY  pchr @ 0< 0= IF pchr @ pchr ON EXIT THEN
  326.   BEGIN EKEY EKEY>CHAR 0= WHILE DROP REPEAT ;
  327. : KEY? pchr @ 0< 0= IF TRUE EXIT THEN
  328.   BEGIN EKEY? CTASK @ 12 + CS: @ setcursor WHILE 
  329.         EKEY EKEY>CHAR IF pchr ! TRUE EXIT THEN DROP 
  330.   REPEAT FALSE ;
  331. : EKEY BEGIN EKEY? CTASK @ 12 + CS: @ setcursor UNTIL 0 7 BDOS 
  332.       ?DUP 0= IF BEGIN EKEY? CTASK @ 12 + CS: @ setcursor UNTIL  
  333.               0 7 BDOS 256 + THEN ;
  334. [ELSE]
  335. : KEY  BEGIN KEY?  CTASK @ 12 + CS: @ setcursor UNTIL  
  336.     0 8 BDOS 
  337.     PAUSE
  338.     nocursor ;
  339. [THEN]
  340.  
  341.  \ ACCEPT
  342.  
  343. 0 0 IN/OUT
  344. : bu  CTASK @ 12 + CS: @ CELL- DUP storecursor BL EMIT storecursor ;
  345.  
  346. DECIMAL
  347.  
  348. : ACCEPT
  349.     inaccept SEMA       \ too hard if two or more tasks want input at once!
  350.     >R 0
  351.     BEGIN
  352.         KEY  CASE
  353.         [CTRL] [ OF 0 ?DO  bu LOOP 0 ENDOF
  354.         [CTRL] H OF DUP IF bu 1- THEN ENDOF
  355.         [CTRL] M OF 
  356.             NIP R> DROP 
  357.             inaccept PHORE 
  358.             EXIT ENDOF
  359.         ( ELSE ) OVER R@ <> IF DUP >R EMIT
  360.             2DUP + R> SWAP C! 1+ 0 THEN
  361.         ENDCASE
  362.     AGAIN ;
  363.  
  364.  
  365.  \ TASK CREATION 
  366. HEX
  367. H: TASK                          \ values after INIT-TASKS:
  368.    CSEG CREATE HERE E92E ,    \ DISP 0 -- JMP ( task asleep )
  369.    DSEG CTASK @ ,  CTASK !    \     02 -- relative addr nxt task
  370.    user @ ,                   \     04 -- size of user area (not used?)
  371.    0 ,                        \     06 -- SS register contents
  372.    user @ pssize 10 * + ,     \     08 -- SP register contents
  373.    user @ pssize 10 * + rssize + , \     0A -- BP register contents
  374.    ,                          \     0C -- PC contents
  375. \ the following fields are for per-task variables
  376. \ and could be selectively elimiated if not needed if space is 
  377. \ at a premium.  In that case, offsets may need to be adjusted
  378. \ for words which use latter fields.
  379.    0 ,                        \     0E -- Message list
  380.    0 ,                        \     10 -- Timer
  381.    0 ,                        \     12 -- Cursor location
  382.    7 ,                        \     14 -- character attribute (style)
  383.    0 ,                        \     16 -- Exception frame pointer
  384.    DSEG HERE 80 ALLOT 22 + ,  \     18 -- PAD, a per-task work area
  385. ; 
  386. 0 [IF]
  387. Initially, DISP 2 has absolute address of next task.
  388. This values as well as DISP 6 get
  389. filled in by INIT-TASKS when application is run.
  390. [THEN]
  391.  
  392. CSEG  CREATE MAIN-TASK  \ Give it a name
  393. HERE DSEG CTASK !             \ Task list points to it
  394. 80CD ,                          \ DISP 0 -- INT 80 (task awake)
  395.    0 ,                          \ 02 -- relative addr next task
  396.    0 ,                          \ 04 -- NOT USED
  397.    0 ,                          \ 06 -- SS register contents
  398.    0 ,                          \ 08 -- SP register contents
  399.    0 ,                          \ 0A -- BP register contents
  400.    0 ,                          \ 0C -- PC contents
  401.    0 ,                          \ 0E -- Message list
  402.    0 ,                          \ 10 -- Timer
  403.    0 ,                          \ 12 -- Cursor Location
  404.    7 ,                          \ 14 -- Style
  405.    0 ,                          \ 16 -- Exception Frame Pointer
  406.    DSEG HERE 80 ALLOT 22 + ,    \ 16 -- PAD, a per-task work area
  407. 0 [IF]
  408. DISP-2, 6, and 12 get filled in by INIT-TASK.  -8 -0A and -0C
  409. are filled by first task swap (which is done by INIT-TASK).
  410. [THEN]
  411.  
  412.  \ TASK INITIALIZATION
  413. 0 0 IN/OUT 
  414. : INIT-TASKS \ This MUST be executed to start multitasking
  415.     CTASK @
  416.     BEGIN ?DUP WHILE  \ for each task DO:
  417.         CELL+ DUP CS: @ IF  \ one follows, this isn't main task
  418.             DUP 8 + CS: @ 10 + 4 RSHIFT  GET 
  419.          OVER 4 + CS: ! \ stackseg
  420.             DUP CS: @ TUCK   \ next task
  421.         ELSE
  422.             0 SWAP CTASK @ \ next task is head of list
  423.         THEN
  424.         OVER - CELL- SWAP CS: !  
  425.     REPEAT
  426.     MAIN-TASK CTASK !  
  427.     setup-vid
  428.     ?SS: MAIN-TASK 6 + CS: !    \ sets main task stack segment
  429.     start-timer
  430.     MULTI ( GO!!! ) ;
  431.  
  432.  \ TASK DISPATCHER
  433. CODE PAUSE  
  434.     0 # ?multi [] CMP  
  435.     =0 IF, RET THEN,
  436.     CTASK [] BX MOV         \ current task
  437.     CS: 0C +[BX] POP        \ save PC
  438.     BP CS: 0A +[BX] MOV     \ save BP
  439.     SP CS: 08 +[BX] MOV     \ save SP
  440.     CS: 2 +[BX] BX ADD  
  441.     4 # BX ADD  
  442.     CLI                \ no ints during dispatch!
  443.     BX JMPI  ( dispatch )
  444. END-CODE \ PAUSE
  445.  
  446. 0 [IF]
  447. Tasks are linked together so that jumping to a task will cause
  448. jumping to the next if it is asleep, or doing an INT 80 if it
  449. is awake.  Thanks to Henry Laxen's Forth 83 model for the
  450. technique.
  451. [THEN]
  452.  
  453. L: start-task ( the INT80 routine )  
  454.     BX POP 
  455.     BX DEC 
  456.     BX DEC                  \ Pointer to the task
  457.     CS: 6 +[BX] SS >SEG     \ restore stack segment
  458.     CS: 8 +[BX] SP MOV      \ restore SP
  459.     STI                     \ Interrupts are safe now
  460.     CS: 0A +[BX] BP MOV     \ restore BP
  461.     BX  CTASK [] MOV        \ current task
  462.     CS: 0C +[BX] JMPI       \ go!
  463. FORTH \ start-task 
  464. 0 [IF]
  465. This code starts up a new task by setting up all registers,
  466. fixing CTASK and USERP, and jumping to where we left off.
  467. [THEN]
  468.  
  469.  \ TASK MANAGEMENT
  470. : SINGLE  ?multi OFF ;
  471.  
  472. : MULTI   ?multi ON
  473.     ?CS: start-task 80 set-handler  \ install interrupt vector
  474.     PAUSE  \ start with a task swap
  475. ;
  476.  
  477. 1 0 IN/OUT
  478. : WAKE  80CD CS: <- ;
  479.  
  480. 1 0 IN/OUT
  481. \ the 2e prefix byte (CS override) makes the jmp instruction 4 bytes long
  482. : SLEEP (  task -- )   E92E CS: <- ;
  483.  
  484. 1 1 IN/OUT
  485. : WAITING?  10 + CS: @ 0<> ;
  486.  
  487. 0 0 IN/OUT
  488. : STOP  CTASK @ SLEEP PAUSE ;
  489.  
  490. 0 1 IN/OUT
  491. : ACTIVE-TASKS
  492.     0 MAIN-TASK
  493.     BEGIN
  494.         DUP WAITING? IF SWAP 1+ SWAP ELSE 
  495.             DUP CS: @ 80CD = IF SWAP 1+ SWAP THEN THEN \ check for active
  496.         DUP CELL+ CS: @ + 4 + \ address of next task
  497.     DUP MAIN-TASK = UNTIL     \ Loop until back to start
  498.     DROP ( task address )
  499. ;
  500.  
  501.  \ MESSAGE PASSING
  502. 0 1 IN/OUT
  503. : MESSAGE?  CTASK @ 0E + CS: @ ;
  504.  
  505. 0 1 IN/OUT
  506. : GET-MESSAGE  
  507.   BEGIN MESSAGE? ?DUP 0= WHILE STOP REPEAT
  508.   DUP  0 @L  CTASK @ 0E + CS: !  \ Unlink message
  509. ;   
  510.  
  511. 1 1 IN/OUT
  512. : MESSAGES 
  513.     0 SWAP 0E + CS: @ ?DUP IF
  514.         BEGIN SWAP 1+ SWAP  0 @L  ?DUP 0= UNTIL
  515.     THEN ;
  516.  
  517. 2 0 IN/OUT
  518. : SEND-MESSAGE 
  519.     OVER 0 SWAP 0 !L        \ set message's next field to NIL
  520.     DUP WAITING? 0= IF DUP WAKE THEN \ fire up receiving task
  521.                                 \ unless waiting for timer
  522.     0E + DUP CS: @ ?DUP IF  \ Existing messages in queue
  523.         NIP
  524.         BEGIN DUP 0 @L ?DUP WHILE NIP REPEAT \ find end of list
  525.         0 !L  \ store message at end of list
  526.     ELSE
  527.         CS: !     \ no existing messages, put at head of queue.
  528.     THEN
  529.     PAUSE ;  \ Give it a chance to run
  530.  
  531.  \ control-break handler
  532. \ always gets control and (currently) dumps task information
  533.  
  534. 2VARIABLE cb_save
  535.  
  536. 1B CONSTANT cb_int
  537.  
  538. 0 0 IN/OUT
  539. : cbt  
  540.     PAGE 
  541.     SINGLE
  542.     end-timer
  543.     ." Task statistics: "
  544.     MAIN-TASK \ start with first
  545.     BEGIN CR
  546.         HEX DUP 0 <# # # # # #> TYPE SPACE \ address
  547.         DUP WAITING? IF ." Waiting " DUP 10 + CS: @ . ." ticks" ELSE 
  548.             DUP CS: @ 80CD = IF ." Active" ELSE ." Sleeping" THEN THEN 
  549.         DUP CELL+ CS: @ + 4 + \ address of next task
  550.     DUP MAIN-TASK = UNTIL     \ Loop until back to start
  551.     DROP ( task address )
  552. EGA [IF]
  553.     CR ." Hit any key when finished"    KEY DROP
  554. [THEN]
  555.     unsetup-vid
  556.     bye
  557. ;
  558.  
  559.  
  560. ' cbt TASK cb-task
  561.  
  562.  
  563. L: cb_handler ( actual interrupt handler )
  564.       80CD # CS: cb-task [] MOV \ wake cb task
  565.     STI
  566.     IRET FORTH
  567.  
  568.  
  569.  \ timer
  570. 1C CONSTANT t_int               \ timer interupt vector number
  571. CSEG 
  572. CREATE t_save 4 ALLOT           \ original interupt vector
  573. L: t_handler
  574.     PUSHF CS: t_save CALLF    \ do original functions
  575.     BX PUSH
  576.     MAIN-TASK # BX MOV ( start of list )
  577.     BEGIN,  
  578.         CS: 0 # 10 +[BX] CMP =0 ~ IF, ( non_zero time )
  579.             CS: 10 +[BX] DEC  ( count down )
  580.             =0 IF, 80CD # CS: [BX] MOV THEN, ( wake task )
  581.         THEN,
  582.         CS: 2 +[BX] BX ADD 
  583.         4 # BX ADD ( next task )
  584.         MAIN-TASK # BX CMP  
  585.     =0 UNTIL, ( back at start? )
  586.     BX POP 
  587.     IRET
  588. FORTH \ t_handler
  589.  
  590. \ timer start and end                          08:09 11/18/85
  591.  
  592. : start-timer  \ and control break handler
  593.     t_int get-handler  t_save CS: 2!
  594.     ?CS: t_handler t_int set-handler
  595.     cb_int get-handler cb_save 2!
  596.     ?CS: cb_handler cb_int set-handler
  597. ;
  598.  
  599. : end-timer
  600.     t_save CS: 2@  t_int set-handler
  601.     cb_save 2@ cb_int set-handler
  602. ;
  603.  
  604. 2 0 IN/OUT
  605. : TIME-OUT ( ticks task -- )  DUP SLEEP 10 + CS: ! ;
  606.  
  607. 1 0 IN/OUT
  608. DECIMAL
  609. : MS ( ticks -- ) 182 10000 */ CTASK @ TIME-OUT PAUSE ;
  610. HEX
  611.  \ Exception Wordset
  612.  
  613. CODE CATCH 
  614.   SI POP  AX POP  \ retAddr execAddr
  615.   CTASK [] BX MOV
  616.   BP DEC BP DEC SI [BP] MOV
  617.   BP DEC BP DEC SP [BP] MOV
  618.   BP DEC BP DEC CS: 16 +[BX] CX MOV  CX [BP] MOV
  619.   BP CS: 16 +[BX] MOV
  620.   AX CALLI
  621.   [BP] AX MOV  AX CS: 16 +[BX] MOV  
  622.   AX AX XOR  AX PUSH
  623.   4 +[BP] AX MOV  6 # BP ADD  
  624.   AX JMPI
  625. END-CODE
  626.  
  627. 1 0 IN/OUT
  628. CODE throw
  629.   CTASK [] BX MOV
  630.   CS: 16 +[BX] BP MOV [BP] BX MOV BX CS: 16 +[BX] MOV
  631.   2 +[BP] SP MOV  AX PUSH
  632.   4 +[BP] AX MOV
  633.   6 # BP ADD  AX JMPI
  634. END-CODE
  635.  
  636. : THROW  ?DUP IF CTASK @ 16 + CS: @ IF throw THEN
  637.        ." Uncaught THROW: " . BYE THEN ;
  638.  
  639.  
  640.  
  641. DSEG 0A = [IF] DECIMAL [THEN]
  642.